home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / contrib / zelk / src-zelk / forfunc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-11-13  |  16.4 KB  |  623 lines
  1. /* forfunc.c zilla 19aug91 - foreign function interface for elk
  2.  *
  3.  * this file creates 
  4.  *      (foreign-prototype <forfunc>)
  5.  *      (foreign-trace! #t/#f)
  6.  * and provides 'foreign
  7.  *
  8.     Portions of this file are Copyright (C) 1991 John Lewis,
  9.     adapted from Elk2.0 by Oliver Laumann.
  10.  
  11.     This file is free software; you can redistribute it and/or modify
  12.     it under the terms of the GNU General Public License as published by
  13.     the Free Software Foundation.
  14.  
  15.     This program is distributed in the hope that it will be useful,
  16.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  17.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18.     GNU General Public License for more details.
  19.  
  20.     You should have received a copy of the GNU General Public License
  21.     along with this program; if not, write to the Free Software
  22.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  23.  
  24.  ****NOTE THE ELK COPYING GC: ALL Object REFERENCES MUST BE GC_LINKED
  25.  ****ACROSS CALLS WHICH MAY ALLOCATE STORAGE.  ALL C VARIABLES WHICH 
  26.  ****ARE ASSIGNED FROM THE ADDRESS OF AN OBJECT MUST BE REASSIGNED
  27.  ****AFTER A GC.
  28.  *
  29.  * foreign functions are defined in an Init_(), using
  30.  * Define_Foreign(char *name,c_entry_point,char *argspec);
  31.  * argspec is a string containing
  32.  *  B boolean
  33.  *  I integer
  34.  *  F float
  35.  *  R returns
  36.  *  S string
  37.  *  P port
  38.  *  A farray
  39.  * currently ports may be passed (C should expect a FILE) but not returned.
  40.  * returned strings are allocated on the lisp heap, so the c function
  41.  * should return a pointer to a static rather than a malloced string
  42.  * (or else there will be a memory leak)
  43.  *
  44.  * modified
  45.  * 12nov
  46.  * 6sep         sparc flush register windows on ff call. needed?
  47.  * 11may        gc checked. probably ok.
  48.  * 17apr        sgi port, cleanups
  49.  * 15oct91      added ZLforudeftab
  50.  * 18sep91      error checking in foreign-prototype
  51.  *
  52.  * naming
  53.  * ZLfordef
  54.  * ZLforcall
  55.  * ZLforproto   return readable form of the prototype
  56.  *
  57.  * Sparc architecture notes%%%%%%%%%%%%%%%%
  58. 32 registers. 8 globals %g0..7, same in every window.  24 window-specific:
  59. %0..31        absolute names for registers
  60. %g0..7        global.  same as %0..7
  61. %o0-7        "out" regs, become "in" for subroutine, same as %8..15
  62. %i0..5        "in registers", are outs of caller. same as %24..31
  63. %i0..5            6th..1st c-program reg var
  64. %l0..7        local    same as %16..23
  65. %f0-31        float regs.  fstod leaves result in 0,1.
  66. %sp=%o6
  67. %fp=%i6
  68. i7=return address
  69. [reg+off]    contents of (*reg)
  70. save,restore create, delete a new register window; syntax is like add
  71. function return values in %o0, %f0,1 for doubles.
  72. call .ptr_call calls routine whos address is in %g1
  73. first 6 args are passed in %o0..%o5, remainder passed on stack.
  74. number of args in registers (<= 6) passed as second arg to call:
  75. call    .ptr_call,6
  76.  
  77. It appears that doubles do not need to be 8-byte aligned when on the stack.
  78.  
  79. stack:
  80.         previous frame
  81.     fp    locals
  82.         alloca
  83.         out parameters beyond 6th        sp+x5c
  84.         6 words - register args for callee    sp+x44..58
  85.         hidden struct return addr word
  86.         16 words save stuff
  87.     sp    ;grows down
  88.     ;;(16+6+1)*4 = 92
  89.  
  90. register layout:
  91.         return addr
  92.         frame pointer
  93.         #in #5..0
  94.         locals
  95.         out:temp    
  96.         stack pointer        becomes callees frame pointer
  97.         out #5..0        become callee's in#5..0 
  98.  
  99. save instruction swaps register windows.  out0..7 become in0..7;
  100. caller's sp becomes callee's fp.
  101. restore instruction undoes this.
  102.  
  103. %i0..5  incoming arguments
  104. sp+x44..58 where caller stores args 0..5 on stack, mirrored in registers o0..5
  105. fp+44     is where first passed argument gets stored if needed, grow up.
  106.     i.e., callee moves i0 into fp+44, i1 int fp+48 if needed.
  107. sp+x5c    Caller stores args beyond 6th here
  108. fp-4     is first local variable, grow down.
  109.  
  110. sp+0x5c should be??? the address of the first out parameter which does
  111.     not fit in a register (arg 7 typically?).
  112.     this becomes fp+0x5c for the callee.
  113. %%%%%%%%%%%%%%%%*/
  114.  
  115. #include <theusual.h>
  116. #include <assert.h>
  117. #include <scheme.h>
  118. #include <zelk.h>
  119.  
  120. /* I integer
  121.    F float
  122.    R returns
  123.    S string
  124.    P port
  125.    A farray
  126.  */
  127.  
  128. /* map 'R' returns indicator onto this dummy type id */
  129. #define T_Returns    254
  130. #define T_End        255
  131.  
  132.  
  133.  
  134. /* primitive (foreign-trace #t/#f) */
  135. static bool ForeignTracep = FALSE;
  136.  
  137. Object P_foreigntrace(o)
  138.   Object o;
  139. {
  140.   Error_Tag = "foreign-trace!";
  141.   if (o == True) ForeignTracep = TRUE;
  142.   else if (o == False) ForeignTracep = FALSE;
  143.   else Primitive_Error("#t or #f");
  144.   return Null;
  145. }
  146.  
  147.  
  148.  
  149. /* primitive define-foreign.  
  150.  * must create a static copy of the argspec, lookup the function symbol,
  151.  * then call Define_Foreign.
  152.  * Should create a separate non-lisp string heap for strings
  153.  * allocated here, and in the foreign function call itself.
  154.  */
  155.  
  156. void P_Define_Foreign (name, fun, args)
  157.   Object name,fun,args;
  158. {
  159.   /* UNFINISHED */
  160. }
  161.  
  162.  
  163.  
  164. /* Define_Foreign - define a foreign function.
  165.  * args may be (char *)0 if function has/returns no arguments.
  166.  * alternate name? ZLfordef()
  167.  */
  168. void Define_Foreign (name, fun, args)
  169.   char *name;
  170.   void (*fun)();
  171.   char *args;
  172. {
  173.     Object prim, sym, frame;
  174.     GC_Node2;
  175.     int len;
  176.     Ztrace(("Define_Foreign %s %s\n",name,args));
  177.     Error_Tag = "define-foreign";
  178.  
  179.     prim = Make_Primitive ( (Object (*)())fun, name, 0, MANY, FOREIGN);
  180.     sym = Null;
  181.     GC_Link2 (prim, sym);
  182.  
  183.     if (args != (char *)0) {
  184.       unsigned char *s;
  185.  
  186.       s = PRIM(prim)->forfunargs = (unsigned char *)Zsalloc(args);
  187.  
  188.       /* WARNING: done in place */
  189.       /* translate from character codes into elk T_ ids */
  190.       while( *s ) {
  191.         switch(*s) {
  192.         case 'B':       *s = (unsigned char)T_Boolean; break;
  193.         case 'I':       *s = (unsigned char)T_Fixnum; break;
  194.         case 'f':       *s = (unsigned char)T_Flonum; break;
  195. # ifdef T_Double
  196.         case 'F':       *s = (unsigned char)T_Double; break;
  197.         case 'D':       *s = (unsigned char)T_Double; break;
  198. # else
  199.         case 'F':       *s = (unsigned char)T_Flonum; break;
  200.         case 'D':       *s = (unsigned char)T_Flonum; break;
  201. # endif
  202.         case 'S':       *s = (unsigned char)T_String; break;
  203.         case 'P':       *s = (unsigned char)T_Port; break;
  204.         case 'A':       *s = (unsigned char)T_Farray; break;
  205.         case 'R':       *s = (unsigned char)T_Returns; break;
  206.         default:
  207.           Ztrace(("(%s) ",PRIM(prim)->forfunargs));
  208.           Primitive_Error("unrecognized argspec");
  209.           break;
  210.         }
  211.         s++;
  212.       } /*while*/
  213.       *s = T_End;
  214.     } /*args!=0*/
  215.     else 
  216.       PRIM(prim)->forfunargs = (unsigned char *)0;
  217.  
  218.     sym = Intern (name);
  219.     frame = Add_Binding (Car (The_Environment), sym, prim);
  220.     SYMBOL(sym)->value = prim;
  221.     Car (The_Environment) = frame;
  222.     GC_Unlink;
  223. } /*Define_Foreign*/
  224.  
  225.  
  226. /* old name of Define_Fortab */
  227. void ZLfordeftab(tab)
  228.   struct fordef *tab;
  229. {
  230.   Define_Fortab(tab);
  231. }
  232.  
  233.  
  234. /* define a table of foreign functions */
  235. void Define_Fortab(tab)
  236.   struct fordef *tab;
  237. {
  238.   struct fordef *f;
  239.   for( f = tab; f->name != (char *)0; f++ ) {
  240.     Ztrace(("fordeftab %s %s\n",f->name,f->args));
  241.     Define_Foreign(f->name,f->ffunc,f->args);
  242.   }
  243. }
  244.  
  245.  
  246. /* define a table of foreign functions with doc strings*/
  247. /* currently (oct-0) the doc string is ignored */
  248. void ZLforudeftab(tab)
  249.   struct fordef_usage *tab;
  250. {
  251.   struct fordef_usage *f;
  252.   for( f = tab; f->name != (char *)0; f++ ) {
  253.     Ztrace(("fordeftab %s %s\n",f->name,f->args));
  254.     Define_Foreign(f->name,f->ffunc,f->args);
  255.   }
  256. }
  257.  
  258.  
  259. /* define primitives via table
  260.    table needs name entry-point minargs maxargs discipline
  261.    NOT DONE YET
  262.    primarily for package-style things.
  263.  */
  264. void ZLdeftab(tab)
  265.   struct fordef *tab;
  266. {
  267.   Panic("ZLdeftab: not implemented");
  268. }
  269.  
  270.  
  271. /* return readable string version of foreign prototype */
  272. char *
  273. ZLforproto(args)
  274.   unsigned char *args;
  275. {
  276.   unsigned char *arg;
  277.   static char cargs[128];
  278.   char *c = cargs;
  279.   Error_Tag = "foreign prototype";
  280.  
  281.   arg = args;
  282.   while( *arg != T_End ) {
  283.     if (*arg == T_Farray)       /* T_Farray is not a constant, wont go */
  284.                                 /* in switch */
  285.       *c++ = 'A';
  286.     else
  287.     switch(*arg) {
  288.     case T_Boolean:     *c++ = 'B'; break;
  289.     case T_Fixnum:      *c++ = 'I'; break;
  290. # ifdef T_Double
  291.     case T_Flonum:      *c++ = 'f'; break;
  292.     case T_Double:      *c++ = 'F'; break;
  293. # else
  294.     case T_Flonum:      *c++ = 'F'; break;
  295. # endif
  296.     case T_Port:        *c++ = 'P'; break;
  297.     case T_String:      *c++ = 'S'; break;
  298.     case T_Returns:     *c++ = 'R'; break;
  299.     default: Primitive_Error("bad id in foreign prototype");
  300.     } /*switch*/
  301.     arg++;
  302.   }
  303.   *c = (char)0;
  304.  
  305.   return cargs;
  306. } /*forproto*/
  307.  
  308.  
  309.  
  310. /* primitive foreign-prototype - rtn argspec string for a foreign func */
  311.  
  312. Object Pforeignprototype(fun)
  313.   Object fun;
  314. {
  315.   struct S_Primitive *prim;
  316.   char *proto;
  317.  
  318.   Error_Tag = "foreign-prototype";
  319.   Check_Type(fun,T_Primitive);
  320.  
  321.   prim = PRIM(fun);
  322.   if (prim->disc != FOREIGN) 
  323.     Primitive_Error("not a foreign function");
  324.   proto = ZLforproto(prim->forfunargs);
  325.  
  326.   return Make_String(proto,str_len(proto));
  327. } /*P_foreignprototype*/
  328.  
  329.  
  330.  
  331. /* Zforfuncall() - call a foreign function!
  332.  * sparc version 
  333.  */
  334. #if Esparc
  335. Object ZLforcall(name,func,proto,ac,av)
  336.   char *name;
  337.   function *func;
  338.   unsigned char *proto;
  339.   int ac;
  340.   Object *av;
  341. {
  342.   register long *_REG1; /* data stacking pointer (must be in r1=%i5) */
  343.   long _LOCAL1,_LOCAL2;    /* first,second local (fp) vars */
  344.  
  345.   int i;                /*fp-x0c now?*/
  346.   Object arg;           /* -x10*/
  347.   char *ptr;            /* -x14?*/
  348.   bool err;             /* -x18?*/
  349.   int4 tmp;             /* -x1c?*/
  350.   double dtmp;        /* double tmp var @fp-0x20? */
  351.   char *cs,*ds;
  352.   int j;
  353.  
  354. # define formaxargs 20
  355.   int intargs[formaxargs];
  356.  
  357. # define strheapsize 1024  
  358.   char strheap[strheapsize];
  359.   char *strptr = strheap;
  360.  
  361.   int padding[512];          /* superstitous? make sure enough stack space */
  362.  
  363.   Error_Tag = "foreign function";
  364.  
  365. #if 0
  366.   __asm__("ta 3"); /* from scm, flush register windows onto the stack.
  367.                       is this necessary or helpful?? */
  368. #endif
  369.  
  370.   if (ForeignTracep)
  371.     printf("%s(%s) #args=%d\n",name,ZLforproto(proto),ac);
  372.   else
  373.     Ztrace(("Zforfuncall %s(%s) ac=%d\n",name,ZLforproto(proto),ac));
  374.  
  375.   if (ac > formaxargs) Primitive_Error("max of 20 args");
  376.  
  377.     /* loop: check argument types, convert int<->flt, stack args.
  378.      * DO NOT DECLARE LOCAL VARIABLES IN BLOCKS BELOW
  379.      * ALSO DO NOT CALL ANY SUBROUTINES
  380.      * variables could occupy the same stack space where
  381.      * the callees frame is being setup (this happened during debugging,
  382.      * see the NONO comment below.
  383.      * ALSO, cannot call any subroutines in this loop, because they
  384.      * may well write over the sp+x44 outparameter assembly area.
  385.      * OR, if calling a subroutine, save this area, and restore it
  386.      * afterwards!
  387.      * NOTE this code depends on T_Returns < T_Ends!!
  388.      */
  389.  
  390.   /* because elk accesses an integer through a subroutine,
  391.    * call this subroutine first before entering the argstacking routine.
  392.    * For elk only.
  393.    */
  394.  
  395.   for( i=0; i < ac; i++ ) {
  396.     arg = av[i];        /* get supplied argument */
  397.     if ((TYPE(arg) == T_Fixnum) || (TYPE(arg) == T_Bignum))
  398.       intargs[i] = Get_Integer(arg);
  399.   }
  400.  
  401.   err = FALSE;
  402.  
  403.   /* move data stacking pointer (future frame pointer) into _REG1 */
  404.   __asm__("    add %sp,0x44,%i5");    /* i5 == REG1 */
  405.  
  406.   for( i=0; i < ac; i++ ) {
  407.  
  408.     if (!proto || (*proto >= T_Returns)) /* too many arguments given */
  409.       { err = TRUE; break; }
  410.  
  411.     arg = av[i];        /* get supplied argument */
  412.  
  413.     if ((TYPE(arg)==*proto) || ((TYPE(arg)==T_Bignum) && (*proto==T_Fixnum)))
  414.     {
  415.  
  416.       /* T_Farray is not a constant, so it is not part of switch below */
  417.       if (*proto == T_Farray)
  418.         *_REG1++ = (long)(FARRAY(arg)->data);
  419.  
  420.       else switch(*proto) {
  421.  
  422.       case T_Flonum:
  423.         /****NO****[double d;]****NO****/
  424.         dtmp = (double)FLONUM(arg)->val;
  425. /*    if ((long)_REG1&0x7) _REG1++; align on 8.doesnt work-why not?*/
  426.         *_REG1++ = *((long *)(&dtmp));
  427.         *_REG1++ = *((long *)(&dtmp)+1);
  428.         break;
  429.  
  430.       case T_Fixnum:
  431.         tmp = intargs[i];
  432.         *_REG1++ = *((long *)&(tmp));
  433.         break;
  434.  
  435.       case T_Boolean:
  436.         *_REG1++ = (arg == True) ? 1 : 0;
  437.         break;
  438.  
  439.       case T_String:
  440.         /* elk does not null-terminate strings on its heap,
  441.          * so we must create a null-terminated copy, without
  442.          * calling any subroutines.
  443.          */
  444.         if ((strptr + STRING(arg)->size) >= (strheap+strheapsize))
  445.           Primitive_Error("string heap is full");
  446.         for( cs=STRING(arg)->data,ds=strptr,j=STRING(arg)->size; j; j-- )
  447.           *ds++ = *cs++;
  448.         *ds = (char)0;
  449.         *_REG1++ = (long)strptr;
  450.         strptr += (STRING(arg)->size + 1);
  451.         break;
  452.  
  453.       case T_Port:
  454.         *_REG1++ = (long)PORT(arg)->file;
  455.         break;
  456.  
  457.       default:
  458.         Primitive_Error("bad type");
  459.         break;
  460.  
  461.       } /*switch*/
  462.     } /* TYPE(arg)==*proto */
  463.  
  464.  /* int<->flt type conversion */
  465.     else {
  466.       if ((*proto == T_Flonum)
  467.           && ((TYPE(arg)==T_Fixnum) || (TYPE(arg)==T_Bignum)))
  468.       {
  469.         dtmp = (float)intargs[i];
  470.         *_REG1++ = *((long *)&dtmp);
  471.         *_REG1++ = *((long *)(&dtmp)+1);
  472.       }
  473.       else if ((*proto == T_Fixnum) && (TYPE(arg)==T_Flonum)) {
  474.         tmp = (int)(double)FLONUM(arg)->val;
  475.         *_REG1++ = *((long *)&(tmp));
  476.       }
  477.       else {
  478.         err = TRUE; break;
  479.       }
  480.     } /*convert type*/
  481.  
  482.     proto++;
  483.   } /*argstackloop*/
  484.  
  485.  
  486.   if (err || (proto && (*proto < T_Returns))) {
  487.     printf("(...%s): ",ZLforproto(proto)); /*&HERE*/
  488.     Primitive_Error("incorrect arguments");
  489.   }
  490.  
  491.     /* setup for calling.  this must appear before asms below */
  492.     _REG1 = (long *)(int4) func;
  493.  
  494.     /* copy first 6 args from stack into registers
  495.      * note could not think of any way to store directly into registers-
  496.      * need a register-indirect(into register) move or store, which
  497.      * doesnt exist.
  498.      */
  499.     __asm__("    ld [%sp+0x44],%o0    ");
  500.     __asm__("    ld [%sp+0x48],%o1    ");
  501.     __asm__("    ld [%sp+0x4c],%o2    ");
  502.     __asm__("    ld [%sp+0x50],%o3    ");
  503.     __asm__("    ld [%sp+0x54],%o4    ");
  504.     __asm__("    ld [%sp+0x58],%o5    ");
  505.  
  506.     /* now do nothing in C until function is called */
  507.  
  508.     /* Invoke the function with the argument list.
  509.      * appears that %g1 always holds the function ptr.
  510.      */
  511.     __asm__("    mov %i5,%g1    ");
  512.     __asm__("    call    .ptr_call,6    ");
  513.     __asm__("    nop    ");  /* do not delete! */
  514.  
  515.     /* copy result into _LOCAL1 (immediately after call)
  516.      * float result in %f0 on sparc, can leave it there.
  517.      */
  518.     __asm__("    st    %o0,[%fp+-0x4]    ");
  519.  
  520.     if (*proto++ == T_Returns) {
  521.  
  522.       if (*proto == T_Boolean)
  523.         return( _LOCAL1 ? True : False );
  524.  
  525.       else if (*proto == T_Fixnum)
  526.         return(Make_Integer(_LOCAL1));
  527.  
  528.       else if (*proto == T_String) {
  529.         if (_LOCAL1 == 0) return(Null);
  530.         /* note elk does not null-terminate strings on its heap */
  531.         return(Make_String((char *)_LOCAL1, str_len((char *)_LOCAL1)));
  532.       }
  533.  
  534.       else if (*proto == T_Flonum) {
  535.         __asm__("    fdtos    %f0,%f0        ");
  536.         __asm__("    st    %f0,[%fp+-0x4]    ");
  537.         return Make_Reduced_Flonum( (double)*((float *)(&_LOCAL1)) );
  538.       }
  539.  
  540.       else if (*proto == T_Port) {
  541.         FILE *f = (FILE *)_LOCAL1;
  542.         return Make_Port( (f->_flag&_IOREAD) ? P_INPUT : 0,
  543.                          f, Make_String("foreign-port",12));
  544.       }
  545.  
  546.       else Primitive_Error("bad return spec.");
  547.     } /*get return value*/
  548.  
  549.   return Null;
  550. } /*forfuncall*/
  551.  
  552. #else /*!sparc*/
  553.  
  554. # if Emips
  555. #  include "FORMIPS.c"
  556. # else
  557.    :error 
  558. #endif
  559.  
  560. #endif /*!Esparc*/
  561.  
  562.  
  563. Object Pprargs(ac,av)
  564.   int ac;
  565.   Object av[];
  566. {
  567.   int i,type;
  568.   Printf(Standard_Output_Port,"prargs: ");
  569.  
  570.   for( i=0; i < ac; i++ ) {
  571.     type = TYPE(av[i]); 
  572.     printf("type:%d ",type);
  573.   } printf("\n");
  574.  
  575.   for( i=0; i < ac; i++ ) {
  576.     Format(Standard_Output_Port,"~s ",3,1,av);
  577.     av++;
  578.   }
  579.   Printf(Standard_Output_Port,"\n");
  580.   return Null;
  581. }
  582.  
  583. Object Pgetstr(ac,av)
  584.   int ac;
  585.   Object *av;
  586. {
  587.   char *s;
  588.   Object str;
  589.  
  590.   if (ac != 1) Primitive_Error("Pgetstr #args");
  591.   Check_Type(*av,T_String);
  592.   str = *av;
  593.   s = STRING(str)->data;
  594.   printf("%s len=%d strlen=%d\n",s,STRING(str)->size,strlen(s));
  595.   return Null;
  596. }
  597.  
  598.  
  599.  
  600. /*%%%%%%%%%%%%%%%% init %%%%%%%%%%%%%%%%*/
  601.  
  602. void Init_foreign()
  603. {
  604.   Ztrace(("Init_foreign--\n"));
  605.   if (T_Farray == 0) Panic("Init_Farray before Z");
  606.  
  607.   /* prelinked functions to test */
  608.   Init_forfunctest();
  609.  
  610.   Define_Primitive(Pgetstr,"Zgetstr",0,MANY,VARARGS);
  611.   Define_Primitive(Pprargs,"Zprargs",0,MANY,VARARGS);
  612.  
  613. /*not useful yet
  614.   Define_Primitive(Zforfuncall,"foreign-call",0,MANY,VARARGS);
  615.  */
  616.  
  617.   Define_Primitive(Pforeignprototype,"foreign-prototype",1,1,EVAL);
  618.   Define_Primitive(P_foreigntrace,"foreign-trace!",1,1,EVAL);
  619.  
  620.   P_Provide(Intern("foreign"));
  621.  
  622. } /*Init_foreign*/
  623.